home *** CD-ROM | disk | FTP | other *** search
/ Tech Arsenal 1 / Tech Arsenal (Arsenal Computer).ISO / tek-02 / tptc16.zip / TPCEXPR.INC < prev    next >
Text File  |  1993-01-04  |  14KB  |  625 lines
  1.  
  2. (*
  3.  * TPTC - Turbo Pascal to C translator
  4.  *
  5.  * (C) 1988 Samuel H. Smith (rev. 13-Feb-88)
  6.  *
  7.  *)
  8.  
  9.  
  10. (*
  11.  * expression parser
  12.  *
  13.  *)
  14.  
  15. function iscall(var lv: string255): boolean;
  16.    {see if the given lvalue is a function call or not}
  17. begin
  18.    iscall := lv[length(lv)] = ')';
  19. end;
  20.  
  21.  
  22. function exprtype(var ex: string255): char;
  23.    {determine expression type and return the printf code for the type}
  24. var
  25.    sym: symptr;
  26.    xt:  char;
  27.    p:   integer;
  28.    id:  string40;
  29.  
  30. begin
  31.    if ex[1] = '''' then
  32.       xt := 'c'
  33.    else
  34.  
  35.    if ex[1] = '"' then
  36.       xt := 's'
  37.    else
  38.  
  39.    begin
  40.       ex[length(ex)+1] := #0;
  41.       p := 1;
  42.       while (ex[p] in ['a'..'z','A'..'Z','0'..'9']) do
  43.          inc(p);
  44.  
  45.       id := copy(ex,1,p-1);
  46.       sym := locatesym(id);
  47.  
  48.       if sym <> nil then
  49.          case sym^.symtype of
  50.             s_char:    xt := 'c';
  51.             s_int:     xt := 'd';
  52.             s_long:    xt := 'D'; { calling routine should convert to "ld" }
  53.             s_double:  xt := 'f';
  54.  
  55.             s_string:
  56.                begin
  57.                   p := length(id) + 1;
  58.                   while (p < length(ex)) and (ex[p] in [' ',^I]) do
  59.                      inc(p);
  60.  
  61.                   if (ex[p] = '[') and (sym^.suptype = ss_scalar) then
  62.                      xt := 'c'
  63.                   else
  64.                      xt := 's';
  65.                end;
  66.  
  67.             else     xt := 'd';
  68.          end
  69.       else
  70.  
  71.       if copy(ex,1,5) = 'scat(' then
  72.          xt := 's'
  73.       else
  74.  
  75.       if copy(ex,1,5) = 'copy(' then
  76.          xt := 's'
  77.       else
  78.  
  79.       if copy(ex,1,5) = 'ctos(' then
  80.          xt := 's'
  81.       else
  82.  
  83.       if copy(ex,1,4) = 'chr(' then
  84.          xt := 'c'
  85.       else
  86.  
  87.       if copy(ex,1,4) = 'ord(' then
  88.          xt := 'd'
  89.  
  90.       else
  91.          xt := 'd'     {all other kinds are defaulted to integer}
  92.    end;
  93.  
  94.    exprtype := xt;
  95. end;
  96.  
  97.  
  98. function strtype(var ex: string255): boolean;
  99.    {see if the expression is a string data type or not}
  100. begin
  101.    case exprtype(ex) of
  102.       's':  strtype := true;
  103.       'c':  strtype := true;
  104.       else  strtype := false;
  105.    end;
  106. end;
  107.  
  108.  
  109.  
  110. function psetof:  string255;
  111.    {parse a literal set; returns the set literal translated into
  112.     the form: setof(.....)}
  113. var
  114.    ex: string255;
  115.  
  116. begin
  117.    gettok;   {consume the [}
  118.    ex := 'setof(';
  119.  
  120.    repeat
  121.       if tok = '..' then       {set ranges are passed as FROM,-2,TO}
  122.       begin                    {and are interpreted by inset()}
  123.          gettok;
  124.          ex := ex + ',THRU,';
  125.       end
  126.       else
  127.  
  128.       if tok = ',' then
  129.       begin
  130.          gettok;
  131.          ex := ex + ',';
  132.       end
  133.       else
  134.  
  135.       if tok <> ']' then
  136.          ex := ex + pexpr;
  137.  
  138.    until tok = ']';
  139.  
  140.    gettok;   {consume the ]}
  141.    ex := ex + ',ENDSET)';
  142.    psetof := ex;
  143. end;
  144.  
  145.  
  146. function pterm:   string255;
  147.    {parse an expression term;  returns the translated expression term;
  148.     detects subexpressions, set literals and lvalues(variable names)}
  149. var
  150.    ex: string255;
  151.  
  152. begin
  153.  
  154.    (* translate NOT term into !term *)
  155.    if tok = 'NOT' then
  156.    begin
  157.       gettok;
  158.       pterm := '!' + pterm;
  159.    end
  160.    else
  161.  
  162.    (* process pos(c,str) and pos(str,str) *)
  163.    if (tok = 'POS') then
  164.    begin
  165.       gettok;   {consume the keyword}
  166.       gettok;   {consume the (}
  167.       ex := pexpr;
  168.       if exprtype(ex) = 'c' then
  169.          ex := 'cpos(' + ex
  170.       else
  171.          ex := 'spos(' + ex;
  172.  
  173.       gettok;   {consume the ,}
  174.       ex := ex + ',' + pexpr;
  175.       gettok;   {consume the )}
  176.       pterm := ex + ')';
  177.    end
  178.    else
  179.  
  180.    (* process port/memory array references *)
  181.    if (tok = 'PORT') or (tok = 'PORTW') or
  182.       (tok = 'MEM')  or (tok = 'MEMW') then
  183.    begin
  184.       if tok = 'PORT'  then ex := 'inportb('    else
  185.       if tok = 'PORTW' then ex := 'inport('     else
  186.       if tok = 'MEM'   then ex := 'peekb('      else
  187.                             ex := 'peek(';
  188.  
  189.       gettok;     {consume the keyword}
  190.       gettok;     {consume the [ }
  191.  
  192.       repeat
  193.          ex := ex + pexpr;
  194.          if tok = ':' then
  195.          begin
  196.             gettok;
  197.             ex := ex + ',';
  198.          end;
  199.       until tok = ']';
  200.  
  201.       gettok;     {consume the ] }
  202.       pterm := ex + ')';
  203.    end
  204.    else
  205.  
  206.    (* translate bitwise not (mt+) *)
  207.    if (tok = '?') or (tok = '~') or (tok = '\') then
  208.    begin
  209.       gettok;
  210.       pterm := '!' + pterm;         {what is a bitwise NOT in c?}
  211.    end
  212.    else
  213.  
  214.    (* process unary minus *)
  215.    if tok = '-' then
  216.    begin
  217.       gettok;
  218.       pterm := '-' + pterm;
  219.    end
  220.    else
  221.  
  222.    (* pass numbers *)
  223.    if toktype = number then
  224.    begin
  225.       pterm := tok;
  226.       gettok;
  227.    end
  228.    else
  229.  
  230.    (* pass strings *)
  231.    if toktype = strng then
  232.    begin
  233.       pterm := tok;
  234.       gettok;
  235.    end
  236.    else
  237.  
  238.    (* pass sub expressions *)
  239.    if tok = '(' then
  240.    begin
  241.       gettok;
  242.       pterm := '(' + pexpr + ')';
  243.       gettok;
  244.    end
  245.    else
  246.  
  247.    (* translate literal sets *)
  248.    if tok = '[' then
  249.    begin
  250.       pterm := psetof;
  251.    end
  252.  
  253.    (* otherwise the term will be treated as an lvalue *)
  254.    else
  255.       pterm := plvalue;
  256. end;
  257.  
  258.  
  259. function pexpr {: string255};
  260.    {top level expression parser; parse and translate an expression and
  261.     return the translated expr}
  262. var
  263.    ex:   string255;
  264.    ty:   char;
  265.    ex2:  string255;
  266.    ty2:  char;
  267.  
  268.    procedure relop(newop: string40);
  269.    begin
  270.       gettok;        {consume the operator token}
  271.       ex2 := pterm;  {get the second term}
  272.  
  273.       {use strcmp if either param is a string}
  274.       ty := exprtype(ex);
  275.       ty2 := exprtype(ex2);
  276.  
  277.       if ty = 's' then
  278.       begin
  279.          if ty2 = 's' then
  280.             ex := 'strcmp(' + ex + ',' + ex2 + ') ' + newop + ' 0'
  281.          else
  282.          if ex2[1] = '''' then
  283.             ex := 'strcmp(' + ex + ',"' + 
  284.                      copy(ex2,2,length(ex2)-2) + '") ' + newop + ' 0'
  285.          else
  286.             ex := 'strcmp(' + ex + ',ctos(' + ex2 + ')) ' + newop + ' 0'
  287.       end
  288.       else
  289.  
  290.       if ty = 'c' then
  291.       begin
  292.          if ty2 = 's' then
  293.             ex := 'strcmp(ctos(' + ex + '),' + ex2 + ') ' + newop + ' 0'
  294.          else
  295.             ex := ex + ' ' + newop + ' ' + ex2
  296.       end
  297.  
  298.       else
  299.          ex := ex + ' ' + newop + ' ' + ex2;
  300.    end;
  301.  
  302.  
  303.    procedure addop;
  304.  
  305.       procedure add_scat;
  306.       var
  307.          p: integer;
  308.  
  309.       begin
  310.          ty := exprtype(ex);
  311.          ty2 := exprtype(ex2);
  312.  
  313.          p := 7;
  314.          while ex[p] <> '"' do
  315.             p := succ(p);
  316.          p := succ(p);
  317.  
  318.          {add literals to the control string if possible}
  319.  
  320.          if (ex2[1] = '''') or (ex2[1] = '"') then
  321.             ex := copy(ex,1,p-2) + copy(ex2,2,length(ex2)-2) +
  322.                   copy(ex,p-1,length(ex)-p+2)
  323.  
  324.          else {add a parameter to the control string}
  325.  
  326.             ex := copy(ex,1,p-2) + '%' + ty2 +
  327.                   copy(ex,p-1,length(ex)-p+1) + ',' + ex2 + ')';
  328.       end;
  329.  
  330.    begin
  331.       gettok;        {consume the operator token}
  332.       ex2 := pterm;  {get the second term}
  333.  
  334.       if copy(ex,1,5) = 'scat(' then
  335.          add_scat
  336.       else
  337.  
  338.       if strtype(ex) or strtype(ex2) then
  339.       begin
  340.          if (ex[1] = '''') or (ex[1] = '"') then
  341.             ex := 'scat("' + copy(ex,2,length(ex)-2) + '")'
  342.          else
  343.             ex := 'scat("%' + exprtype(ex) + '",' + ex + ')';
  344.          add_scat;
  345.       end
  346.       else
  347.          ex := ex + ' + ' + ex2;
  348.    end;
  349.  
  350.    procedure mulop(newop: string40);
  351.    begin
  352.       gettok;        {consume the operator token}
  353.       ex2 := pterm;  {get the second term}
  354.       ex := ex + ' ' + newop + ' ' + ex2;
  355.    end;
  356.  
  357.  
  358. begin
  359.    ex := pterm;
  360.  
  361.    while true do
  362.    begin
  363.       (* process operators *)
  364.       if      tok = '>'   then relop(tok)
  365.       else if tok = '<'   then relop(tok)
  366.       else if tok = '>='  then relop(tok)
  367.       else if tok = '<='  then relop(tok)
  368.       else if tok = '<>'  then relop('!=')
  369.       else if tok = '='   then relop('==')
  370.       else if tok = '+'   then addop
  371.       else if tok = '-'   then mulop(tok)
  372.       else if tok = '*'   then mulop(tok)
  373.       else if tok = '/'   then mulop(tok)
  374.       else if tok = 'DIV' then mulop('/')
  375.       else if tok = 'MOD' then mulop('%')
  376.       else if tok = 'AND' then mulop('&&')
  377.       else if tok = 'OR'  then mulop('||')
  378.       else if tok = 'SHR' then mulop('>>')
  379.       else if tok = 'SHL' then mulop('<<')
  380.       else if tok = 'XOR' then mulop('^')
  381.       else if tok = '&'   then mulop(tok)  {mt+}
  382.       else if tok = '!'   then mulop('|')  {mt+}
  383.       else if tok = '|'   then mulop('|')  {mt+}
  384.       else
  385.  
  386.       (* translate the expr IN set operator *)
  387.       if tok = 'IN'  then
  388.       begin
  389.          gettok;
  390.          ex := 'inset('+ex+', ' + pterm + ')';
  391.       end
  392.       else
  393.  
  394.       (* ran out of legal expression operators; return what we found *)
  395.       begin
  396.          pexpr := ex;
  397.          exit;
  398.       end;
  399.    end;
  400.  
  401. end;
  402.  
  403.  
  404. function plvalue{: string255};
  405.    {parse and translate an lvalue specification and return the translated
  406.     lvalue as a string}
  407.  
  408. var
  409.    lv:   string255;
  410.    v:    string255;
  411.    tv:   string255;
  412.    pref: anystring;
  413.    idok: boolean;
  414.    sym:  symptr;
  415.    func: symptr;
  416.    pvars:integer;
  417.    ind:  string40;
  418.  
  419. begin
  420.  
  421. (* lvalues must begin with an identifier in pascal *)
  422.    if toktype <> identifier then
  423.       error('Identifier expected (plvalue)');
  424.  
  425. (* assign initial part of the lvalue *)
  426.    lv := ltok;
  427.    v := tok;
  428.    idok := false;
  429.    pref := '';
  430.  
  431.    gettok;
  432.    sym := locatesym(lv);
  433.    if sym <> nil then
  434.    begin
  435. {      if in_locals and past_marker then
  436.          pref := 'nest_' + nestn + '_';  }
  437.  
  438.       if sym^.parcount = -2 then
  439.          pref := '*' + pref;
  440.    end;
  441.  
  442. (* process a list of qualifiers and modifiers *)
  443.    repeat
  444.  
  445.       (* additional identifiers (field names) *)
  446.       if idok and (toktype = identifier) then
  447.       begin
  448.          lv := lv + ltok;
  449.          gettok;
  450.          idok := false;
  451.       end
  452.       else
  453.  
  454.       (* pointers *)
  455.       if tok = '^' then
  456.       begin
  457.          pref := '*' + pref;
  458.          gettok;
  459.       end
  460.       else
  461.  
  462.       (* pointer subscripts *)
  463.       if tok = '^[' then
  464.       begin
  465.          pref := '*{?}' + pref;         {should this be here?}
  466.          lv := lv + '[';
  467.          gettok;
  468.  
  469.          while tok <> ']' do
  470.          begin
  471.             lv := lv + pexpr;
  472.             if tok = ',' then
  473.             begin
  474.                lv := lv + '][';
  475.                gettok;
  476.             end;
  477.          end;
  478.  
  479.          lv := lv + ']';
  480.          gettok;
  481.       end
  482.       else
  483.  
  484.       (* pointer members *)
  485.       if tok = '^.' then
  486.       begin
  487.          lv := lv + '->';
  488.          gettok;
  489.          idok := true;
  490.       end
  491.       else
  492.  
  493.       (* record members *)
  494.       if tok = '.' then
  495.       begin
  496.          if pref = '*' then     {translate *id. into id->}
  497.          begin
  498.             pref := '';
  499.             lv := lv + '->';
  500.          end
  501.          else
  502.             lv := lv + '.';
  503.          idok := true;
  504.          gettok;
  505.       end
  506.       else
  507.  
  508.       (* subscripts *)
  509.       if tok = '[' then
  510.       begin
  511.          sym := locatesym(lv);
  512.  
  513.          if copy(pref,1,1) = '*' then
  514.             pref := '';       {replace '*id[' with 'id['}
  515.  
  516.          lv := lv + '[';
  517.          gettok;
  518.  
  519.          while tok <> ']' do
  520.          begin
  521.             lv := lv + pexpr;
  522.  
  523.             if sym <> nil then
  524.                if sym^.symtype = s_string then
  525.                   lv := lv + '-1';
  526.  
  527.             if tok = ',' then
  528.             begin
  529.                lv := lv + '][';
  530.                gettok;
  531.             end;
  532.          end;
  533.  
  534.          lv := lv + ']';
  535.          gettok;
  536.       end
  537.       else
  538.  
  539.       (* function calls *)
  540.       if tok = '(' then
  541.       begin
  542.          func := findsym(globals, v);
  543.          pvars := 0;
  544.          if func <> nil then
  545.             pvars := func^.pvar;
  546.          lv := lv + '(';
  547.          gettok;
  548.  
  549.          while tok <> ')' do
  550.          begin
  551.             ind := '';
  552.             if (pvars and 1) = 1 then
  553.                ind := '&';
  554.             tv := pexpr;
  555.  
  556.             if ind = '&' then   {var parameter?  pass pointer}
  557.             begin
  558.                if tv[1] = '*' then      {address of pointer deref is ptr}
  559.                begin
  560.                   delete(tv,1,1);
  561.                   ind := '';
  562.                end
  563.                else
  564.  
  565.                if tv[1] in ['a'..'z','A'..'Z'] then
  566.                begin                    {pass pointer to strings/arrays}
  567.                   sym := locatesym(tv);
  568.                   if sym <> nil then
  569.                      if (sym^.symtype = s_string) or
  570.                         (sym^.suptype = ss_array) then
  571.                        ind := '';
  572.                end;
  573. {               else
  574.                   ind := ''; }
  575.             end;
  576.  
  577.             lv := lv + ind + tv;
  578.             pvars := pvars shr 1;
  579.  
  580.             if (tok = ',') or (tok = ':') then
  581.             begin
  582.                lv := lv + ', ';
  583.                gettok;
  584.             end;
  585.          end;
  586.  
  587.          lv := lv + ')';
  588.          gettok;
  589.       end
  590.       else
  591.  
  592. (* otherwise just return what was found so far *)
  593.       begin
  594.  
  595.          (* add dummy param list to function calls where the proc
  596.             expects no parameters *)
  597.          sym := locatesym(lv);
  598.  
  599.          if sym <> nil then
  600.          begin
  601.             if sym^.parcount = 0 then
  602.                lv := lv + '()'
  603.             else
  604.  
  605.             if sym^.parcount > 0 then
  606.                if not iscall(lv) then
  607.                   lv := lv + '()';
  608.          end;
  609.  
  610.          if v = 'PARAMCOUNT' then
  611.             lv := '(argc-1)'
  612.          else
  613.  
  614.          if v = 'PARAMSTR' then
  615.             lv := 'argv[' + copy(lv,10,length(lv)-10) + ']';
  616.  
  617.          plvalue := pref + lv;
  618.          exit;
  619.       end;
  620.  
  621.    until true=false;
  622.  
  623. end;
  624.  
  625.